unit CoreScript;

interface

uses
	SysUtils, uPSCompiler, uPSRuntime, CoreTypes;

//OnBeforeCleanup

type
	TScriptUnit = class(TListItem)
		onUses, onImport, onVars: TProc;
	end;

	TScriptUnits = specialize TList<TScriptUnit>;

	TScript = class(TListItem)
		fileName: String;
		units: array of TScriptUnit;
		unitsLen: Integer;
		text, data: String;
		importer: TPSRuntimeClassImporter;
		exec: TPSExec;

		constructor Create;
		destructor Destroy; override;
	end;

	TScripts = specialize TList<TScript>;

	TScriptMan = class(TScripts)
		units: TScriptUnits;
		scripts: TScripts;
		curScript: TScript;
		compiler: TPSPascalCompiler;

		function AddUnit(name: String; onUses, onImport, onVars: TProc): TScriptUnit;
		function Add(text: String; runAndFree: Boolean = False): TScript;
		function AddFromFile(fileName: String; runAndFree: Boolean = False): TScript;

		constructor Create;
		destructor Destroy; override;
	end;

var
	scr: TScriptMan;

//units uses/import/vars
procedure ConOnUses;
procedure ConOnImport;
procedure ConOnVar;

implementation

uses
	CoreConsole;

constructor TScript.Create;
begin
	SetLength(units, 20);

	unitsLen := 0;

	importer := TPSRuntimeClassImporter.Create;
	exec := TPSExec.Create;
end;

destructor TScript.Destroy;
begin
	FreeAndNil(exec);
	FreeAndNil(importer);
end;

function OnUses(compiler: TPSPascalCompiler; const name: String): Boolean;
var
	unit_: TScriptUnit;
begin
	Result := False;

	//system unit uses
	if Name = 'SYSTEM' then
	begin
		with scr.compiler do
		begin
			AddTypeS('TProc', 'procedure()');
			AddTypeS('Pointer', 'Longint');
			AddTypeS('TStrings', 'array of String');
			AddTypeS('TBytes', 'array of Byte');
		end;

		Result := True;
		Exit;
	end;

	//other units
	unit_ := scr.units.Find(name);

	if unit_ = nil then
	begin
		con.Msg('#Ошибка компиляции скрипта: не удается найти модуль "' + name + '"');
		Exit;
	end;

	scr.curScript.units[scr.curScript.unitsLen] := unit_;
	scr.curScript.unitsLen += 1;

	unit_.onUses;

	Result := True;
end;

constructor TScriptMan.Create;
begin
	units := TScriptUnits.Create;
	scripts := TScripts.Create;
	curScript := nil;
	compiler := TPSPascalCompiler.Create;
	compiler.OnUses := @OnUses;

	AddUnit('CoreConsole', @ConOnUses, @ConOnImport, @ConOnVar);
end;

destructor TScriptMan.Destroy;
begin
	FreeAndNil(compiler);
	FreeAndNil(scripts);
	FreeAndNil(units);
end;

function TScriptMan.AddUnit(name: String; onUses, onImport, onVars: TProc): TScriptUnit;
begin
	Result := units.Add(TScriptUnit.Create);
	Result.name := UpperCase(name);
	Result.onUses := onUses;
	Result.onImport := onImport;
	Result.onVars := onVars;
end;

function TScriptMan.Add(text: String; runAndFree: Boolean = False): TScript;
var
	i: Integer;
begin
	Result := TScript.Create;
	Result.text := text;

	curScript := Result;

	//compile
	if not compiler.Compile(text) then
	begin
		con.Msg('#Не удается скомпилировать скрипт:');

		for i := 0 to compiler.MsgCount -1 do
		begin
			con.Msg('#' + compiler.Msg[i].MessageToString);
		end;

		Exit;
	end;

	compiler.GetOutput(Result.data);

	//import
	for i := 0 to Result.unitsLen - 1 do
	begin
		if Result.units[i].onImport <> nil then
		begin
			Result.units[i].onImport;
		end;
	end;

	RegisterClassLibraryRuntime(Result.exec, Result.importer);

	//execute
	if not Result.exec.LoadData(Result.data) then
	begin
		con.Msg('#Ошибка при загрузке скрипта');
		Result.Free;
		Result := nil;
		Exit;
	end;

	//vars
	for i := 0 to Result.unitsLen - 1 do
	begin
		if Result.units[i].onVars <> nil then
		begin
			Result.units[i].onVars;
		end;
	end;

	if runAndFree then
	begin
		Result.exec.RunScript;
		Result.Free;
		Result := nil;

		curScript := nil;

		Exit;
	end;

	scripts.Add(Result);
end;

function TScriptMan.AddFromFile(fileName: String; runAndFree: Boolean = False): TScript;
var
	f: File;
	text: String;
begin
	Result := nil;

	con.Msg('Загрузка скрипта "' + fileName + '"');

	{$I-}
	AssignFile(f, fileName);
	Reset(f, 1);
	{$I+}

	if IOResult <> 0 then
	begin
		con.Msg('#Не удается открыть файл скрипта "' + fileName + '"');
		Exit;
	end;

	SetLength(text, FileSize(f));

	BlockRead(f, text[1], Length(text));

	CloseFile(f);

	Result := Add(text, runAndFree);

	if Result <> nil then
	begin
		Result.fileName := fileName;
	end;
end;

//////////////////////////////////////////////////////////////////////////////
/// Core units uses/import/vars
//////////////////////////////////////////////////////////////////////////////

//console
procedure ConOnUses;
begin
	//TConsoleVar
	with scr.compiler do
	begin
		AddConstantN('CON_INT', 'Longint').Value^.ts32 := CON_INT;
		AddConstantN('CON_FLOAT', 'Longint').Value^.ts32 := CON_FLOAT;
		AddConstantN('CON_BOOL', 'Longint').Value^.ts32 := CON_BOOL;
		AddConstantN('CON_STR', 'Longint').Value^.ts32 := CON_STR;
		AddConstantN('CON_PROC', 'Longint').Value^.ts32 := CON_PROC;

		with AddClassN(nil, 'TConsoleVar') do
		begin
			RegisterMethod('procedure SetInt(val: Integer)');
			RegisterMethod('procedure SetSin(val: Single)');
			RegisterMethod('procedure SetBool(val: Boolean)');
			RegisterMethod('procedure SetStr(val: String)');
			RegisterMethod('procedure SetProc(val: TProc)');

			RegisterMethod('function GetInt: Integer');
			RegisterMethod('function GetSin: Single');
			RegisterMethod('function GetBool: Boolean');
			RegisterMethod('function GetStr: String');
			RegisterMethod('function GetProc: TProc');
		end;
	end;

	//TConsole
	with scr.compiler.AddClassN(nil, 'TConsole') do
	begin
		RegisterMethod('procedure Msg(const text: String)');
		RegisterMethod('procedure Cmd(text: String)');

		RegisterMethod('function Add(name: String; typ: Integer; ptr: Pointer): TConsoleVar');
		RegisterMethod('function Find(name: String): TConsoleVar');
		RegisterMethod('procedure Rem(cv: TConsoleVar)');
	end;

	AddImportedClassVariable(scr.compiler, 'con', 'TConsole');
end;

procedure ConOnImport;
begin
	//TConsoleVar
	with scr.curScript.importer.Add(TConsoleVar) do
	begin
		RegisterMethod(@TConsoleVar.SetInt, 'SETINT');
		RegisterMethod(@TConsoleVar.SetSin, 'SETSIN');
		RegisterMethod(@TConsoleVar.SetBool, 'SETBOOL');
		RegisterMethod(@TConsoleVar.SetStr, 'SETSTR');
		//RegisterMethod('procedure SetProc, 'SETPROC');

		RegisterMethod(@TConsoleVar.GetInt, 'GETINT');
		RegisterMethod(@TConsoleVar.GetSin, 'GETSIN');
		RegisterMethod(@TConsoleVar.GetBool, 'GETBOOL');
		RegisterMethod(@TConsoleVar.GetStr, 'GETSTR');
		//RegisterMethod('function GetProc, 'GETPROC');
	end;

	//TConsole
	with scr.curScript.importer.Add(TConsole) do
	begin
		RegisterMethod(@TConsole.Msg, 'MSG');
		RegisterMethod(@TConsole.Cmd, 'CMD');

		RegisterMethod(@TConsole.Add, 'ADD');
		RegisterMethod(@TConsole.Find, 'FIND');
		RegisterMethod(@TConsole.Rem, 'REM');
	end;
end;

procedure ConOnVar;
begin
	SetVariantToClass(scr.curScript.exec.GetVarNo(scr.curScript.exec.GetVar('CON')), con);
end;

//////////////////////////////////////////////////////////////////////////////
/// End
//////////////////////////////////////////////////////////////////////////////

end.
